home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / ALLABOUT.FRM < prev    next >
Text File  |  1997-06-14  |  16KB  |  485 lines
  1. VERSION 5.00
  2. Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
  3. Begin VB.Form FAllAbout 
  4.    Caption         =   "All About..."
  5.    ClientHeight    =   5640
  6.    ClientLeft      =   2016
  7.    ClientTop       =   4020
  8.    ClientWidth     =   8604
  9.    BeginProperty Font 
  10.       Name            =   "MS Sans Serif"
  11.       Size            =   7.8
  12.       Charset         =   0
  13.       Weight          =   700
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    Icon            =   "ALLABOUT.frx":0000
  19.    LinkTopic       =   "Form1"
  20.    ScaleHeight     =   5640
  21.    ScaleWidth      =   8604
  22.    Begin TabDlg.SSTab tabAbout 
  23.       Height          =   4452
  24.       Left            =   336
  25.       TabIndex        =   0
  26.       Top             =   636
  27.       Width           =   7836
  28.       _ExtentX        =   13822
  29.       _ExtentY        =   7853
  30.       _Version        =   327680
  31.       Tabs            =   4
  32.       TabsPerRow      =   4
  33.       TabHeight       =   420
  34.       BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
  35.          Name            =   "MS Sans Serif"
  36.          Size            =   7.8
  37.          Charset         =   0
  38.          Weight          =   700
  39.          Underline       =   0   'False
  40.          Italic          =   0   'False
  41.          Strikethrough   =   0   'False
  42.       EndProperty
  43.       TabCaption(0)   =   "System"
  44.       TabPicture(0)   =   "ALLABOUT.frx":0442
  45.       Tab(0).ControlCount=   1
  46.       Tab(0).ControlEnabled=   -1  'True
  47.       Tab(0).Control(0)=   "lbl(0)"
  48.       Tab(0).Control(0).Enabled=   0   'False
  49.       TabCaption(1)   =   "Video"
  50.       TabPicture(1)   =   "ALLABOUT.frx":045E
  51.       Tab(1).ControlCount=   1
  52.       Tab(1).ControlEnabled=   0   'False
  53.       Tab(1).Control(0)=   "lbl(1)"
  54.       Tab(1).Control(0).Enabled=   0   'False
  55.       TabCaption(2)   =   "Drives"
  56.       TabPicture(2)   =   "ALLABOUT.frx":047A
  57.       Tab(2).ControlCount=   2
  58.       Tab(2).ControlEnabled=   0   'False
  59.       Tab(2).Control(0)=   "cmdDrives"
  60.       Tab(2).Control(0).Enabled=   -1  'True
  61.       Tab(2).Control(1)=   "lbl(2)"
  62.       Tab(2).Control(1).Enabled=   0   'False
  63.       TabCaption(3)   =   "Version"
  64.       TabPicture(3)   =   "ALLABOUT.frx":0496
  65.       Tab(3).ControlCount=   3
  66.       Tab(3).ControlEnabled=   0   'False
  67.       Tab(3).Control(0)=   "cmdVersion"
  68.       Tab(3).Control(0).Enabled=   -1  'True
  69.       Tab(3).Control(1)=   "lblFile"
  70.       Tab(3).Control(1).Enabled=   0   'False
  71.       Tab(3).Control(2)=   "lbl(3)"
  72.       Tab(3).Control(2).Enabled=   0   'False
  73.       Begin VB.CommandButton cmdVersion 
  74.          Caption         =   "New..."
  75.          Height          =   372
  76.          Left            =   -68376
  77.          TabIndex        =   6
  78.          Top             =   3792
  79.          Width           =   972
  80.       End
  81.       Begin VB.CommandButton cmdDrives 
  82.          Caption         =   "Refresh"
  83.          Height          =   372
  84.          Left            =   -68412
  85.          TabIndex        =   5
  86.          Top             =   3804
  87.          Width           =   972
  88.       End
  89.       Begin VB.Label lblFile 
  90.          Height          =   192
  91.          Left            =   -74916
  92.          TabIndex        =   7
  93.          Top             =   336
  94.          Width           =   2964
  95.       End
  96.       Begin VB.Label lbl 
  97.          Height          =   3972
  98.          Index           =   0
  99.          Left            =   120
  100.          TabIndex        =   4
  101.          Top             =   360
  102.          Width           =   7620
  103.       End
  104.       Begin VB.Label lbl 
  105.          Height          =   3516
  106.          Index           =   3
  107.          Left            =   -74880
  108.          TabIndex        =   3
  109.          Top             =   756
  110.          Width           =   7584
  111.       End
  112.       Begin VB.Label lbl 
  113.          Height          =   3972
  114.          Index           =   2
  115.          Left            =   -74892
  116.          TabIndex        =   2
  117.          Top             =   336
  118.          Width           =   7644
  119.       End
  120.       Begin VB.Label lbl 
  121.          Height          =   3972
  122.          Index           =   1
  123.          Left            =   -74772
  124.          TabIndex        =   1
  125.          Top             =   360
  126.          Width           =   7512
  127.       End
  128.    End
  129.    Begin VB.Menu mnuFile 
  130.       Caption         =   "&File"
  131.       Begin VB.Menu mnuAbout 
  132.          Caption         =   "&About"
  133.       End
  134.       Begin VB.Menu mnuExit 
  135.          Caption         =   "E&xit"
  136.       End
  137.    End
  138. End
  139. Attribute VB_Name = "FAllAbout"
  140. Attribute VB_GlobalNameSpace = False
  141. Attribute VB_Creatable = False
  142. Attribute VB_PredeclaredId = True
  143. Attribute VB_Exposed = False
  144. Option Explicit
  145.  
  146. Private sExe As String
  147. Private fUpdate As Boolean
  148. Private sFilterString As String
  149.  
  150. Const ordSystem = 0
  151. Const ordVideo = 1
  152. Const ordDrives = 2
  153. Const ordVersion = 3
  154.  
  155. Private Sub Form_Initialize()
  156.     BugLocalMessage "Initializing All About"
  157. End Sub
  158.  
  159. Private Sub Form_Load()
  160.             
  161.     BugLocalMessage "Loading All About"
  162.     sExe = "vb5.exe"
  163.     ' Tranfer to any previous instance
  164.     If App.PrevInstance Then
  165.         Dim sTitle As String
  166.         ' Save my title
  167.         sTitle = Me.Caption
  168.         ' Change my title bar so I won't activate myself
  169.         Me.Caption = Hex$(Me.hWnd)
  170.         ' Activate other instance
  171.         AppActivate sTitle
  172.         ' Terminate myself
  173.         End
  174.     End If
  175.     
  176.     If IsExe() Then sExe = App.EXEName & ".EXE"
  177.     
  178.     Show
  179.     DoEvents
  180.     ' Try every which way to make first tab display
  181.     tabAbout.Tab = 0
  182.     DoEvents
  183.     tabAbout.TabVisible(0) = True
  184.     DoEvents
  185.     tabAbout_Click 1
  186.      
  187.     sFilterString = "Executable (*.exe;*.dll;*.vbx;*.ocx;*.fon):*.exe;*.dll;*.vbx;*.ocx;*.fon"
  188.     sFilterString = sFilterString & "Program (*.exe):*.exe" & "|"
  189.     sFilterString = sFilterString & "DLL (*.dll):*.dll" & "|"
  190.     sFilterString = sFilterString & "Control (*.vbx;*.ocx):*.vbx;*.ocx" & "|"
  191.     sFilterString = sFilterString & "Font (*.fon):*.fon"
  192.  
  193.     Refresh
  194.           
  195. End Sub
  196.  
  197. Private Sub Form_Activate()
  198.     BugLocalMessage "Activating All About"
  199. End Sub
  200.  
  201. Private Sub Form_Unload(Cancel As Integer)
  202.     BugLocalMessage "Unloading All About"
  203. End Sub
  204.    
  205. Private Sub Form_Terminate()
  206.     BugLocalMessage "Terminating All About"
  207. End Sub
  208.  
  209. Private Sub cmdAbout_Click()
  210.     mnuAbout_Click
  211. End Sub
  212.  
  213. Private Sub cmdExit_Click()
  214.     mnuExit_Click
  215. End Sub
  216.  
  217. Private Sub cmdDrives_Click()
  218.     fUpdate = True
  219.     tabAbout_Click (0)
  220. End Sub
  221.  
  222. Private Sub cmdVersion_Click()
  223.     Dim f As Boolean, sFile As String, fReadOnly As Boolean
  224.     f = VBGetOpenFileName( _
  225.             filename:=sFile, _
  226.             ReadOnly:=fReadOnly, _
  227.             Filter:=sFilterString, _
  228.             Owner:=hWnd)
  229.     If f And sFile <> sEmpty Then
  230.         sExe = sFile
  231.         tabAbout_Click 0
  232.     End If
  233. End Sub
  234.  
  235. Private Sub mnuAbout_Click()
  236.     Dim about As New CAbout
  237.     With about
  238.         On Error GoTo FailAbout
  239.         ' Set properties
  240.         Set .Client = App
  241.         Set .Icon = Forms(0).Icon
  242.         .UserInfo(2) = "Don't even think " & _
  243.                             "about stealing this program"
  244.         ' Load after all properties are set
  245.         .Load
  246.         ' Modal form will return here when finished
  247.         Exit Sub
  248.     End With
  249. FailAbout:
  250.         MsgBox "I don't know nuttin'"
  251. End Sub
  252.  
  253. Private Sub mnuExit_Click()
  254.     Unload Me
  255. End Sub
  256.  
  257. Private Sub tabAbout_Click(PreviousTab As Integer)
  258.     Dim s As String
  259.     Select Case tabAbout.Tab
  260.     Case ordSystem
  261.         lbl(ordSystem) = ShowSystem
  262.         
  263.     Case ordVideo
  264.         lbl(ordVideo) = ShowVideo
  265.     
  266.     Case ordDrives
  267.         lbl(ordDrives).Caption = "Getting drive information..."
  268.         lbl(ordDrives).Refresh
  269.         lbl(ordDrives).Caption = ShowDrives(fUpdate)
  270.         fUpdate = False
  271.         cmdDrives.Visible = True
  272.  
  273.     Case ordVersion
  274.         lblFile.Caption = sExe
  275.         lbl(ordVersion) = ShowVersion(sExe)
  276.         
  277.     End Select
  278.     
  279. End Sub
  280.  
  281. Private Function ShowSystem() As String
  282.     Dim s As String
  283.     s = "Free Physical Memory: " & System.FreePhysicalMemory & " KB" & sCrLf & _
  284.         "Available Physical Memory: " & System.TotalPhysicalMemory & " KB" & sCrLf & _
  285.         "Free Virtual Memory: " & System.FreeVirtualMemory & " KB" & sCrLf & _
  286.         "Available Virtual Memory: " & System.TotalVirtualMemory & " KB" & sCrLf & _
  287.         "Free Page File: " & System.FreePageFile & " KB" & sCrLf & _
  288.         "Available Page File: " & System.TotalPageFile & " KB" & sCrLf & _
  289.         "Memory Load: " & System.MemoryLoad & "%" & sCrLf & _
  290.         "Windows Version: " & System.WinMajor & "." & System.WinMinor & sCrLf & _
  291.         "Processor: " & System.Processor & sCrLf & _
  292.         "Mode: " & System.Mode & sCrLf & _
  293.         "Windows Directory: " & System.WindowsDir & sCrLf & _
  294.         "System Directory: " & System.SystemDir & sCrLf & _
  295.         "User Name: " & System.User & sCrLf & _
  296.         "Machine Name: " & System.Machine & sCrLf
  297.     ShowSystem = s
  298. End Function
  299.  
  300. Private Function ShowDrives(fUpdate As Boolean) As String
  301.  
  302.     Static s As String
  303.     If Not fUpdate And s <> sEmpty Then
  304.         ShowDrives = s
  305.         Exit Function
  306.     End If
  307.     
  308.     Dim driveCur As New CDrive
  309.     driveCur = 0       ' Initialize to current drive
  310.     
  311.     Debug.Print driveCur
  312.     s = "Drive information for current drive:" & sCrLf
  313.     Const sBFormat = "#,###,###,##0"
  314.     With driveCur
  315.         s = s & "Drive " & .Root & " [" & .Label & ":" & _
  316.                 .Serial & "] (" & .KindStr & ") has " & _
  317.                 Format$(.FreeBytes, sBFormat) & " free from " & _
  318.                 Format$(.TotalBytes, sBFormat) & sCrLf
  319.     End With
  320.     
  321.     driveCur = "C:\"       ' Initialize to current drive
  322.     
  323.     s = "Drive information for drive C:" & sCrLf
  324.     Debug.Print driveCur
  325.     With driveCur
  326.         s = s & "Drive " & .Root & " [" & .Label & ":" & _
  327.                 .Serial & "] (" & .KindStr & ") has " & _
  328.                 Format$(.FreeBytes, sBFormat) & " free from " & _
  329.                 Format$(.TotalBytes, sBFormat) & sCrLf
  330.     End With
  331.     
  332.     s = s & sCrLf
  333.     s = s & "Drive information for available drives:" & sCrLf
  334.     Dim drives As New CDrives, drive As CDrive
  335.     For Each drive In drives
  336.         With drive
  337.             s = s & "Drive " & .Root & " [" & .Label & ":" & _
  338.                     .Serial & "] (" & .KindStr & ") has " & _
  339.                     Format$(.FreeBytes, sBFormat) & " free from " & _
  340.                     Format$(.TotalBytes, sBFormat) & sCrLf
  341.         End With
  342.     Next
  343.     Debug.Print drives("C:\").Label
  344.     ShowDrives = s
  345.     
  346. End Function
  347.         
  348. Private Function ShowVersion(sFile As String) As String
  349.     Dim vc As New CVersion, s As String
  350.     On Error Resume Next
  351.     vc = sFile
  352.     If Err Or vc.EXEName = sEmpty Then
  353.         lbl(ordVersion).Caption = "Can't get version"
  354.         Exit Function
  355.     End If
  356.     
  357.     If vc.Description <> sEmpty Then
  358.         s = s & "Description: " & vc.Description & sCrLf
  359.     End If
  360.     If vc.InternalName <> sEmpty Then
  361.         s = s & "Internal name: " & vc.InternalName & sCrLf
  362.     End If
  363.     If vc.OriginalFilename <> sEmpty Then
  364.         s = s & "Original filename: " & vc.OriginalFilename & sCrLf
  365.     End If
  366.     If vc.TimeStamp <> 0& Then
  367.         s = s & "Time stamp: " & vc.TimeStamp & sCrLf
  368.     End If
  369.     s = s & "File version: " & vc.FullFileVersion & sCrLf
  370.     s = s & "Product version: " & vc.FullProductVersion & sCrLf
  371.     If vc.FileVersionString <> sEmpty Then
  372.         s = s & "File version string: " & vc.FileVersionString & sCrLf
  373.     End If
  374.     If vc.ProductVersionString <> sEmpty Then
  375.         s = s & "Product version string: " & vc.ProductVersionString & sCrLf
  376.     End If
  377.     If vc.ProductName <> sEmpty Then
  378.         s = s & "Product: " & vc.ProductName & sCrLf
  379.     End If
  380.     If vc.Company <> sEmpty Then
  381.         s = s & "Company: " & vc.Company & sCrLf
  382.     End If
  383.     If vc.Comments <> sEmpty Then
  384.         s = s & "Comments: " & vc.Comments & sCrLf
  385.     End If
  386.     If vc.BuildString <> sEmpty Then
  387.         s = s & "Build: " & vc.BuildString & sCrLf
  388.     End If
  389.     If vc.Environment <> sEmpty Then
  390.         s = s & "Environment: " & vc.Environment & sCrLf
  391.     End If
  392.     If vc.ExeType <> sEmpty Then
  393.         s = s & "Executable type: " & vc.ExeType & sCrLf
  394.     End If
  395.     If vc.Copyright <> sEmpty Then
  396.         s = s & "Copyright: " & vc.Copyright & sCrLf
  397.     End If
  398.     If vc.Trademarks <> sEmpty Then
  399.         s = s & "Trademarks: " & vc.Trademarks & sCrLf
  400.     End If
  401.     Dim sT As String
  402.     sT = vc.Custom("CustomBuild")
  403.     If sT <> sEmpty Then
  404.         s = s & "Custom build: " & sT & sCrLf
  405.     End If
  406.     sT = vc.Custom("SpecialBuild")
  407.     If sT <> sEmpty Then
  408.         s = s & "Special build: " & sT & sCrLf
  409.     End If
  410.     Dim dt As Date
  411.     dt = vc.TimeStamp
  412.     If dt <> 0 Then
  413.         s = s & "Time stamp: " & dt & sCrLf
  414.     End If
  415.     ShowVersion = s
  416. End Function
  417.  
  418. Private Function ShowVideo() As String
  419.     Dim s As String
  420.     With Video
  421.         s = "Display type: " & _
  422.             Choose(.TECHNOLOGY + 1, "Plotter", "Raster Display", _
  423.                 "Raster Printer", "Raster Camera", "Character Stream", _
  424.                 "Metafile", "Display File") & sCrLf
  425.         s = s & "Screen size: " & .XPixels & "," & .YPixels & sCrLf
  426.         s = s & "Bits per pixel: " & .BitsPerPixel
  427.         s = s & "  Color Planes: " & .ColorPlanes
  428.         s = s & "  Palette size: " & .PaletteSize & sCrLf
  429.         s = s & "Brushes: " & .BrushCount
  430.         s = s & "  Pens: " & .PenCount
  431.         s = s & "  Fonts: " & .FontCount
  432.         s = s & "  Colors: " & .ColorCount & sCrLf
  433.         s = s & "Transparent blits: " & .TransparentBlt & sCrLf
  434.         s = s & "Aspect: X=" & .XAspect & ", Y=" & .YAspect & ", XY=" & .XYAspect & sCrLf
  435.         
  436.         Dim af As Long
  437.         s = s & "Raster: "
  438.         af = .RasterCapability
  439.         If af And RC_BITBLT Then s = s & "BitBlt "
  440.         If af And RC_BITMAP64 Then s = s & "BigBitmaps "
  441.         If af And RC_FLOODFILL Then s = s & "FloodFill "
  442.         If af And RC_PALETTE Then s = s & "Palette "
  443.         If af And RC_STRETCHBLT Then s = s & "StretchBlt "
  444.         If .TransparentBlt Then s = s & "TransparentBlt "
  445.         s = s & sCrLf
  446.         
  447.         s = s & "Curves: "
  448.         af = .CurveCapability
  449.         If af And CC_CIRCLES Then s = s & "Circles "
  450.         If af And CC_PIE Then s = s & "Pie"
  451.         If af And CC_CHORD Then s = s & "Chord "
  452.         If af And CC_ELLIPSES Then s = s & "Ellipses "
  453.         If af And CC_ROUNDRECT Then s = s & "RoundRect "
  454.         s = s & sCrLf
  455.         
  456.         s = s & "Lines: "
  457.         af = .LineCapability
  458.         If af And LC_POLYLINE Then s = s & "PolyLine "
  459.         If af And LC_MARKER Then s = s & "Marker "
  460.         If af And LC_POLYMARKER Then s = s & "PolyMarker "
  461.         s = s & sCrLf
  462.         
  463.         s = s & "Polygons: "
  464.         af = .PolygonCapability
  465.         If af And PC_POLYGON Then s = s & "Polygon "
  466.         If af And PC_RECTANGLE Then s = s & "Rectangle "
  467.         If af And PC_WINDPOLYGON Then s = s & "WindPolygon "
  468.         If af And PC_SCANLINE Then s = s & "ScanLine "
  469.         s = s & sCrLf
  470.         
  471.         s = s & "Text: "
  472.         af = .TextCapability
  473.         If af And TC_CR_90 Then s = s & "Rotate 90"
  474.         If af And TC_CR_ANY Then s = s & "RotateAny "
  475.         If af And TC_IA_ABLE Then s = s & "Italic "
  476.         If af And TC_UA_ABLE Then s = s & "Underline "
  477.         If af And TC_SO_ABLE Then s = s & "StrikeOut "
  478.         If af And TC_RA_ABLE Then s = s & "Raster "
  479.         If af And TC_VA_ABLE Then s = s & "Vector "
  480.         s = s & sCrLf
  481.                
  482.     End With
  483.     ShowVideo = s
  484. End Function
  485.